home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / w3-xemac.el.z / w3-xemac.el
Encoding:
Text File  |  1998-05-21  |  6.9 KB  |  202 lines
  1. ;;; w3-xemac.el --- XEmacs specific functions for emacs-w3
  2. ;; Author: wmperry
  3. ;; Created: 1998/01/09 14:38:05
  4. ;; Version: 1.24
  5. ;; Keywords: faces, help, mouse, hypermedia
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10. ;;;
  11. ;;; This file is part of GNU Emacs.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;;; Boston, MA 02111-1307, USA.
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28.  
  29. (require 'w3-imap)
  30. (require 'images)
  31. (require 'w3-widget)
  32. (require 'w3-menu)
  33. (require 'w3-forms)
  34. (require 'w3-script)
  35. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36. ;;; Enhancements For XEmacs
  37. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38. (defun w3-text-pixel-width (str &optional face)
  39.   "Return the pixel-width of a chunk of text STR with face FACE."
  40.   (let ((glyph (make-glyph str))
  41.     (todo (if (listp face) face (list face)))
  42.     (max 0))
  43.     (while (progn (set-glyph-face glyph (pop todo)) todo)
  44.       (setq max (max (glyph-width glyph) max)))
  45.     max))
  46.   
  47. (defun w3-mouse-handler (e)
  48.   "Function to message the url under the mouse cursor"
  49.   (interactive "e")
  50.   (let* ((pt (event-point e))
  51.      (good (eq (event-window e) (selected-window)))
  52.      (mouse-events))
  53.     (if (not (and good pt (number-or-marker-p pt)))
  54.     nil
  55.       (if (and inhibit-help-echo w3-track-mouse)
  56.       (widget-echo-help pt))
  57.       (setq mouse-events (w3-script-find-event-handlers pt 'mouse))
  58.       (if (assq 'onmouseover mouse-events)
  59.       (w3-script-evaluate-form (cdr (assq 'onmouseover mouse-events)))))))
  60.  
  61. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62. ;;; Functions to build menus of urls
  63. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  64. (defun w3-setup-version-specifics ()
  65.   "Set up routine for XEmacs 19.12 or later"
  66.   ;; Create the toolbar buttons
  67.   (and (featurep 'toolbar)
  68.        (w3-toolbar-make-buttons))
  69.  
  70.   ;; Register the default set of image conversion utilities
  71.   (image-register-netpbm-utilities)
  72.  
  73.   ;; Add our menus, but make sure that we do it to the global menubar
  74.   ;; not the current one, which could be anything, but usually GNUS or
  75.   ;; VM if not the default.
  76.   (if (featurep 'menubar)
  77.       (let ((current-menubar (default-value 'current-menubar)))
  78.     (if current-menubar
  79.         (add-submenu '("Help") (cons "WWW" (cdr w3-menu-help-menu))))))
  80.  
  81.   ;; FIXME FIXME: Do sexy things to the default modeline for Emacs-W3
  82.   
  83.   ;; The following is a workaround for XEmacs 19.14 and XEmacs 20.0
  84.   ;; The text property implementation is badly broken - you could not have
  85.   ;; a text property with a `nil' value.  Bad bad bad.
  86.   (if (or (and (= emacs-major-version 20)
  87.            (= emacs-minor-version 0))
  88.       (and (= emacs-major-version 19)
  89.            (= emacs-minor-version 14)))
  90.       (defun text-prop-extent-paste-function (ext from to)
  91.     (let ((prop (extent-property ext 'text-prop nil))
  92.           (val nil))
  93.       (if (null prop)
  94.           (error "Internal error: no text-prop"))
  95.       (setq val (extent-property ext prop nil))
  96.       (put-text-property from to prop val nil)
  97.       nil))
  98.     )
  99.   )
  100.  
  101. (defun w3-store-in-clipboard (str)
  102.   "Store string STR into the clipboard in X"
  103.   (cond
  104.    ((eq (device-type) 'tty)
  105.     nil)
  106.    ((eq (device-type) 'x)
  107.     (x-own-selection str))
  108.    ((eq (device-type) 'ns)
  109.     )
  110.    (t nil)))
  111.  
  112. (defun w3-mode-motion-hook (e)
  113.   (let* ((glyph  (event-glyph e))
  114.      (x      (and glyph (event-glyph-x-pixel e)))
  115.      (y      (and glyph (event-glyph-y-pixel e)))
  116.      (widget (and glyph (glyph-property glyph 'widget)))
  117.      (usemap (and widget (w3-image-widget-usemap widget)))
  118.      (ismap  (and widget (widget-get widget 'ismap)))
  119.      (echo   (and widget (widget-get widget 'href))))
  120.     (cond
  121.      (usemap
  122.       (setq echo (w3-point-in-map (vector x y) usemap t)))
  123.      (ismap
  124.       (setq echo (format "%s?%d,%d" echo x y)))
  125.      (t
  126.       nil))
  127.     (and echo (message "%s" echo))))
  128.  
  129. (defun w3-mode-version-specifics ()
  130.   "XEmacs specific stuff for w3-mode"
  131.   (if (featurep 'mouse)
  132.       (progn
  133.     (if (not w3-track-mouse)
  134.         (setq inhibit-help-echo nil))
  135.     (setq mode-motion-hook 'w3-mouse-handler)))
  136.   (case (device-type)
  137.     ((tty stream)            ; TTY or batch
  138.      nil)
  139.     (otherwise
  140.      (w3-add-toolbar-to-buffer)))
  141.   (setq mode-popup-menu w3-popup-menu))
  142.  
  143. (if (string-match "19\\.13" emacs-version)
  144.     ;; This is all from Vladimir Alexiev <vladimir@cs.ualberta.ca>
  145.     (progn
  146.       (require 'advice)
  147.       (declare (special widget-use-overlay-change))
  148.       (defadvice add-text-properties (before face-list activate)
  149.     "Allow a list of faces (ignore all but first one)."
  150.     (let ((faces (plist-get props 'face)))
  151.       (if (listp faces)
  152.           (plist-put props 'face (car faces)))))
  153.  
  154.       (defadvice set-extent-property (before face-list activate)
  155.     "Allow a list of faces (ignore all but first one)."
  156.     (if (and (eq property 'face) (listp value))
  157.         (setq value (car value))))
  158.  
  159.       (defadvice insert-char (before inherit-ignore 
  160.                      (char &optional count inherit buffer)
  161.                      activate)
  162.     "Accept and ignore a third arg INHERIT."
  163.     (or (bufferp inherit) (setq inherit buffer)))
  164.  
  165.  
  166.       (defun font-height (font) 1)
  167.       (defun font-width (font)    1)    ; works for tty
  168.       (defalias 'get-char-property 'get-text-property)
  169.       (defalias 'extent-object 'extent-buffer)
  170.       (defvar shell-command-switch "-c") ; for mm
  171.  
  172.       ;; for x-overlay
  173.       (defun extent-list (&optional buffer from to)
  174.     "Return a list of all extents in BUFFER between FROM and TO 
  175. \(see mapcar-extents\)."
  176.     (mapcar-extents 'identity nil buffer from to))
  177.  
  178.       ;; for custom/widget
  179.       (setq widget-use-overlay-change nil) ; slower, but works
  180.  
  181.       (defadvice add-hook (before ignore 
  182.                   (hook function &optional append ignore)
  183.                   activate)
  184.     "Accept and ignore a fourth argument.")
  185.  
  186.       (defadvice remove-hook (before ignore 
  187.                      (hook function &optional ignore) activate)
  188.     "Accept and ignore a third argument.")
  189.  
  190.       (defun valid-image-instantiator-format-p (format)
  191.     (valid-instantiator-p
  192.      (vector format :file (concat "foo." (symbol-name format)))
  193.      'image))
  194.  
  195.       (defadvice make-sparse-keymap (before ignore (&optional name) activate)
  196.     "Accept and ignore an optional arg NAME.")
  197.       ))
  198.  
  199. (require 'w3-toolbar)
  200. (provide 'w3-xemacs)
  201. (provide 'w3-xemac)
  202.